home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Thomas 1.1 sources / implementation-specific.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  11.4 KB  |  327 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*                      Director, Cambridge Research Lab
  21. ;*                      Digital Equipment Corp
  22. ;*                      One Kendall Square, Bldg 700
  23. ;*                      Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: gambit-specific.scm,v 1.6 1992/09/23 19:29:03 birkholz Exp $
  39. ;;fixed bug in implementation-specific:enter-debugger Ray Laning
  40. ;;;; This file contains the definitions of all functions used in the
  41. ;;;; implementation of Dylan which aren't part of R4RS.
  42.  
  43. ;;;; Populations
  44.  
  45. ;(load "poplat")
  46.  
  47. ;;;; Hash tables that use weak links for objects
  48.  
  49. ;(load "hash")
  50.  
  51. ;;;; Record package
  52.  
  53. (define (error:wrong-type-argument record-type expected-type procedure)
  54.   (error (string-append
  55.            "Record package,"
  56.            (symbol->string procedure)
  57.            ": wrong argument type.  Expected "
  58.            expected-type
  59.            ", got ")
  60.          record-type))
  61.  
  62. (define (error:bad-range-argument field-name procedure-name)
  63.   (error (string-append
  64.            "Record package,"
  65.            (symbol->string procedure-name)
  66.            ": unknown field name")
  67.          field-name))
  68.  
  69. ;(load "record")
  70.  
  71. ;;;; Compiler's error procedure.
  72.  
  73. (define (dylan::error string . args)
  74.   (apply error (string-append "Error: " string) args))
  75.  
  76. ;;;; Load-up
  77.  
  78. (define (implementation-specific:generate-file in-exprs out-expr)
  79.   (define (print x) (newline) (display x))
  80.   (define (pp-to-string exprs)
  81.     (let ((port (open-output-string)))
  82.       (for-each (lambda (x) (newline port) (pp x port))
  83.                 exprs)
  84.       (let ((str (get-output-string port)))
  85.         (close-output-port port)
  86.         str)))
  87.   (define (split-char-list chars continue)
  88.     (let loop ((output '())
  89.                (chars chars))
  90.       (cond ((null? chars)
  91.              (continue (list->string (reverse output)) '()))
  92.             ((char=? (car chars) #\newline)
  93.              (continue (list->string (reverse output)) (cdr chars)))
  94.             (else (loop (cons (car chars) output) (cdr chars))))))
  95.   (define (string->strings string)
  96.     (let loop ((output '())
  97.                (input (string->list string)))
  98.       (if (null? input)
  99.           (reverse output)
  100.           (split-char-list input
  101.             (lambda (string rest-chars)
  102.               (loop (cons string output) rest-chars))))))
  103.   (print ";;;; Input expressions:")
  104.   (for-each (lambda (line)
  105.               (if (not (zero? (string-length line))) (display "; "))
  106.               (display line)
  107.               (newline))
  108.             (string->strings (pp-to-string in-exprs)))
  109.   (print ";;;; Compiled output:")
  110.   (newline)
  111.   (print "(##declare (standard-bindings) (not safe))")
  112.   (newline)
  113.   (pp out-expr)
  114.   (newline))
  115.  
  116. ;;;; Eval
  117.  
  118. (define (implementation-specific:eval expression)
  119.   (eval expression))
  120.  
  121. ;;;; Interface between Dylan condition system (runtime-exceptions.scm) and
  122. ;;;; native condition system.
  123.  
  124. (define *dylan-handlers* '())
  125.  
  126. (define (implementation-specific:push-handler
  127.          type function test description thunk)
  128.   (dynamic-wind
  129.    (lambda ()
  130.      (set! *dylan-handlers* (cons (list type function test description)
  131.                                   *dylan-handlers*)))
  132.    thunk
  133.    (lambda ()
  134.      (set! *dylan-handlers* (cdr *dylan-handlers*)))))
  135.  
  136. (define (implementation-specific:get-dylan-handler-frames)
  137.   *dylan-handlers*)
  138.  
  139. ;;;supply missing out argument to newline - RL
  140. (define (implementation-specific:enter-debugger dylan-condition)
  141.   ;; implementation-specific:enter-debugger is only called by `break',
  142.   ;; so I label the ##debug-repl with "*** Breakpoint".
  143.   ;; Printing the arguments to `break':
  144.   (##call-with-current-continuation
  145.     (lambda (cont)
  146.       (##sequentially
  147.         (lambda ()
  148.           (let ((out (##repl-out)))
  149.             (##newline out)
  150.             (##write-string
  151.              (dylan-call dylan:condition-format-string dylan-condition)
  152.              out)
  153.             (##newline out)
  154.             (##newline out)
  155.             (##write-string "*** Breakpoint" out)
  156.             (##newline out)
  157.             (##debug-repl cont)))))))
  158.  
  159. (define (implementation-specific:induce-error format-string format-args)
  160.   (letrec ((printit
  161.             (lambda
  162.               (obj port)
  163.               (cond ((instance? obj)
  164.                      (##format
  165.                       port "#[~S] "
  166.                            (vector-ref (vector-ref obj 1) 1)))
  167.                     ((class? obj)
  168.                      (##format port "#[Class ~S] " (vector-ref obj 1)))
  169.                     ((list? obj)
  170.                      (do ((subarg obj (cdr subarg)))
  171.                          ((null? subarg))
  172.                        (printit (car subarg) port)))
  173.                     (#t (display obj port))))))
  174.     (do ((thisarg format-args (cdr thisarg))
  175.          (outstring (open-output-string)))
  176.         ((null? thisarg)
  177.          (apply error (string-append
  178.                        format-string " " (get-output-string outstring)) 3))
  179.       (printit (car thisarg) outstring))
  180.     ;  (apply error format-string format-args)
  181.     ))
  182.  
  183. (define (implementation-specific:induce-type-error value class-name)
  184.   (error (string-append "not an instance of " (symbol->string class-name) ":")
  185.         value))
  186.  
  187. (define (implementation-specific:signal-unhandled-dylan-condition
  188.          dylan-condition)
  189.   (error "unhandled condition:" dylan-condition))
  190.  
  191. (define (implementation-specific:warning format-string format-args)
  192.   (newline) (display "*** WARNING -- ")
  193.   (display-simple-error format-string format-args))
  194.  
  195. (define (display-simple-error format-string format-args)
  196.   (display format-string)
  197.   (do ((args format-args (cdr args)))
  198.       ((null? args) #t)
  199.     (display " ")(write (car args))))
  200.  
  201. ;;; Gambit errors consist of constant objects denoting the error type,
  202. ;;; plus a list of "args".  To hand both pieces of info to the Thomas
  203. ;;; error reflector, cons them together.  Here're the operations.
  204. ;(define make-condition (lambda (x y) (cons x '())))
  205. (define make-condition (lambda (x y) (cons x y))) ;let 'em have the args
  206. (define condition-type car)
  207. (define condition-args cdr)
  208.  
  209. (define (implementation-specific:catch-all-errors handler thunk)
  210.   (##catch-all (lambda (s args) (handler (make-condition s args))) thunk))
  211.  
  212. ;;; All gambit errors will be reflected as <simple-errors>.  We
  213. ;;; convert any types to some, usually descriptive, string.
  214.  
  215. (define (implementation-specific:get-error-message scheme-condition)
  216.   (let ((s (condition-type scheme-condition)))
  217.     (set! foo scheme-condition)
  218.     (case s
  219.       ((##SIGNAL.IO-ERROR)
  220.        "io-error")
  221.       ((##SIGNAL.READ-ERROR)
  222.        "read-error")
  223.       ((##SIGNAL.UNBOUND-DYNAMIC-VAR)
  224.        "unbound-dynamic-var")
  225.       ((##SIGNAL.GLOBAL-UNBOUND)
  226.        "global-unbound")
  227.       ((##SIGNAL.GLOBAL-UNBOUND-OPERATOR)
  228.        "global-unbound-operator")
  229.       ((##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR)
  230.        "global-non-procedure-operator")
  231.       ((##SIGNAL.NON-PROCEDURE-JUMP)
  232.        "non-procedure-jump")
  233.       ((##SIGNAL.NON-PROCEDURE-OPERATOR)
  234.        "non-procedure-operator")
  235.       ((##SIGNAL.NON-PROCEDURE-SEND)
  236.        "non-procedure-send")
  237.       ((##SIGNAL.WRONG-NB-ARG)
  238.        "wrong-nb-arg")
  239.       ((##SIGNAL.APPLY-ARG-LIMIT)
  240.        "apply-arg-limit")
  241.       ((##SIGNAL.HEAP-OVERFLOW)
  242.        "heap-overflow")
  243.       ((##SIGNAL.STACK-OVERFLOW)
  244.        "stack-overflow")
  245.       ((##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED)
  246.        "placeholder-already-determined")
  247.       ((##SIGNAL.RUNTIME-ERROR)
  248.        "runtime-error")
  249.       ((##SIGNAL.GLOBAL-ENV-OVERFLOW)
  250.        "global-env-overflow")
  251.       ((##SIGNAL.SYNTAX-ERROR)
  252.        "syntax-error")
  253.       (else
  254.        "other-error"))))
  255.  
  256. (define (implementation-specific:get-error-arguments scheme-condition)
  257.   (condition-args scheme-condition))
  258.  
  259. (define (implementation-specific:is-reflected-error? string args)
  260.   ;; Can't tell which <simple-error>s are reflected Gambit errors or
  261.   ;; which are user-generated.  (Actually, if we kept track of the
  262.   ;; above string constants, we could recognize them again.)  I don't
  263.   ;; know how to continue from the catch-all error handler anyway.
  264.   #f)
  265.  
  266. (define (implementation-specific:let-scheme-handle-it serious)
  267.   ;; If implementation-specific:is-reflected-error? always returns #f,
  268.   ;; this should never be called.
  269.   (error "unexpected call to implementation-specific:let-scheme-handle-it"))
  270.  
  271. ;;;; Additional Dylan bindings
  272.  
  273. (define (dylan:scheme-variable-ref mv nm variable-name)
  274.   (eval variable-name))
  275.  
  276. (define (dylan:scheme-procedure-ref mv nm variable-name)
  277.   (make-dylan-callable (eval variable-name)))
  278.  
  279. (define (dylan:pp mv nm obj)
  280.   mv nm                                 ; Ignored
  281.   (pp obj))
  282.  
  283. (define (dylan:load mv nm filename)
  284.   (let ((scheme-filename (string-append filename ".scm")))
  285.     (thomas->scheme filename scheme-filename)
  286.     (load scheme-filename)
  287.     filename))
  288.  
  289. (define (dylan:named-load mv nm filename scheme-filename)
  290.   (thomas->scheme filename scheme-filename)
  291.   (load scheme-filename)
  292.   scheme-filename)
  293.  
  294. (define implementation-specific:additional-dylan-bindings
  295.   `((pp dylan:pp)
  296.     (scheme-variable dylan:scheme-variable-ref)
  297.     (scheme-procedure dylan:scheme-procedure-ref)
  298.     (load dylan:load)
  299.     (named-load dylan:named-load)))
  300.  
  301. ;;;; Other things
  302.  
  303. ;;; For conversion from strings to symbols, we need a function that
  304. ;;; canonicalizes the case of the string.
  305.  
  306. (define canonicalize-string-for-symbol
  307.   (let ((converter (if (char=? #\a (string-ref (symbol->string 'a) 0))
  308.                        char-downcase
  309.                        char-upcase)))
  310.     (lambda (string)
  311.       (list->string (map converter (string->list string))))))
  312.  
  313. ;(load "msort")
  314.  
  315. (define (write-line x)
  316.   (write x)
  317.   (newline))
  318.  
  319. ;;; pp -- already provided
  320.  
  321. ;(load "dynwind")
  322.  
  323. ;;; Imaginary numbers aren't supported by all implementations
  324. (define (get-+i) +i)
  325.  
  326. (define thomas-rep-module-variables '()) ;moved here from rep.scm
  327.